home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / GNUST / !GNUst / st / ClassDescr < prev    next >
Text File  |  1991-09-13  |  7KB  |  279 lines
  1. "======================================================================
  2. |
  3. |   ClassDescription Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  11. | Written by Steve Byrne.
  12. |
  13. | This file is part of GNU Smalltalk.
  14. |
  15. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  16. | under the terms of the GNU General Public License as published by the Free
  17. | Software Foundation; either version 1, or (at your option) any later version.
  18. | 
  19. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  20. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  21. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  22. | details.
  23. | 
  24. | You should have received a copy of the GNU General Public License along with
  25. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  26. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  27. |
  28.  ======================================================================"
  29.  
  30.  
  31. "
  32. |     Change Log
  33. | ============================================================================
  34. | Author       Date       Change 
  35. | sbyrne     23 Sep 89      fileOutCategory: is dangerous, so I make it write to
  36. |              a subdirectory called './categories'.
  37. |
  38. | sbyrne     25 Apr 89      created.
  39. |
  40. "
  41.  
  42. Behavior subclass: #ClassDescription
  43.      instanceVariableNames: 'name comment instanceVariables category'
  44.      classVariableNames: ''
  45.      poolDictionaries: ''
  46.      category: nil.
  47.  
  48. ClassDescription comment: 
  49. 'My instances record information generally attributed to classes and
  50. metaclasses; namely, the class name, class comment (you wouldn''t be
  51. reading this if it weren''t for me), a list of the instance variables
  52. of the class, and the class category.  I provide methods that
  53. access classes by category, and allow whole categories of classes to be
  54. filed out to external disk files.' !
  55.  
  56.  
  57.  
  58. !ClassDescription methodsFor: 'accessing class description'!
  59.  
  60. name
  61.     ^name
  62. !
  63.  
  64. comment
  65.     ^comment
  66. !
  67.  
  68. comment: aString
  69.     comment _ aString
  70. !
  71.  
  72. addInstVarName: aString
  73.     instanceVariables _ instanceVariables copyWith: aString
  74. !
  75.  
  76. removeInstVarName: aString
  77.     instanceVariables _ instanceVariables copyWithout: aString
  78. !!
  79.  
  80.  
  81.  
  82. !ClassDescription methodsFor: 'organization of messages and classes'!
  83.  
  84. category
  85.     ^category
  86. !
  87.  
  88. category: aString
  89.     aString isNil
  90.     ifTrue: [ category _ nil ]
  91.     ifFalse: [ category _ aString asSymbol ]
  92. !
  93.  
  94. removeCategory: aString
  95.     | selector method category |
  96.     methodDictionary isNil
  97.         ifTrue: [ ^self ].
  98.     category _ aString asSymbol.
  99.     methodDictionary associationsDo:
  100.         [ :assoc | method _ assoc key.
  101.                method methodCategory = category
  102.                ifTrue: [ methodDictionary remove: assoc ] ].
  103. !
  104.  
  105. whichCategoryIncludesSelector: selector
  106.     | method |
  107.     methodDictionary isNil
  108.         ifTrue: [ ^nil ].
  109.     method _ methodDictionary at: selector.
  110.     ^method methodCategory
  111. !!
  112.  
  113.  
  114.  
  115. !ClassDescription methodsFor: 'copying'!
  116.  
  117. copy: selector from: aClass
  118.     | method |
  119.     method _ aClass compiledMethodAt: selector.
  120.     methodDictionary at: selector put: method.
  121. !
  122.  
  123. copy: selector from: aClass classified: categoryName
  124.     | method |
  125.     method _ (aClass compiledMethodAt: selector) deepCopy.
  126.     method methodCategory: categoryName.
  127.     methodDictionary at: selector put: method
  128. !
  129.  
  130. copyAll: arrayOfSelectors from: class
  131.     arrayOfSelectors do:
  132.     [ :selector | self copy: selector
  133.                from: class ]
  134. !
  135.  
  136. copyAll: arrayOfSelectors from: class classified: categoryName
  137.     arrayOfSelectors do:
  138.     [ :selector | self copy: selector
  139.                from: class
  140.                classified: categoryName ]
  141. !
  142.  
  143. copyAllCategoriesFrom: aClass
  144.     | method |
  145.     aClass selectors do:
  146.     [ :selector | self copy: selector from: aClass ]
  147. !
  148.  
  149. copyCategory: categoryName from: aClass
  150.     | method |
  151.     aClass selectors do:
  152.     [ :selector | method _ aClass compiledMethodAt: selector.
  153.               method methodCategory = categoryName
  154.               ifTrue: [ self copy: selector from: aClass ] ]
  155. !
  156.  
  157. copyCategory: categoryName from: aClass classified: newCategoryName
  158.     | method |
  159.     aClass selectors do:
  160.     [ :selector | method _ aClass compiledMethodAt: selector.
  161.               method methodCategory = categoryName
  162.               ifTrue: [ self copy: selector
  163.                      from: aClass
  164.                      classified: newCategoryName ] ]
  165. !!
  166.  
  167.  
  168.  
  169. !ClassDescription methodsFor: 'compiling'!
  170.  
  171. compile: code classified: categoryName
  172.     | method |
  173.     self notYetImplemented
  174. !
  175.  
  176. compile: code classified: categoryName notifying: requestor
  177.     self notYetImplemented
  178. !!
  179.  
  180.  
  181.  
  182. !ClassDescription methodsFor: 'accessing instances and variables'!
  183.  
  184. instVarNames
  185.     ^instanceVariables
  186. !!
  187.  
  188.  
  189.  
  190. !ClassDescription methodsFor: 'printing'!
  191.  
  192. classVariableString
  193.     self subclassResponsibility
  194. !
  195.  
  196. instanceVariableString
  197.     | aString |
  198.     instanceVariables isNil ifTrue: [ ^'' ].
  199.     aString _ String new: 0.
  200.     instanceVariables do: [ :instVarName | aString _ aString ,
  201.                                               instVarName , ' ' ].
  202.     ^aString
  203. !
  204.  
  205. sharedVariableString
  206.     self subclassResponsibility
  207. !!
  208.  
  209.  
  210.  
  211. !ClassDescription methodsFor: 'filing'!
  212.  
  213. fileOutOn: aFileStream
  214.     | categories now |
  215.     categories _ Set new.
  216.     methodDictionary isNil ifTrue: [ ^self ].
  217.     methodDictionary do:
  218.     [ :method | categories add: (method methodCategory) ].
  219.     '''Filed out from ' printOn: aFileStream.
  220.     Version printOn: aFileStream.
  221.     ' on ' printOn: aFileStream.
  222.     now _ Date dateAndTimeNow.
  223.     (now at: 1) printOn: aFileStream.
  224.     '  ' printOn: aFileStream.
  225.     (now at: 2) printOn: aFileStream.
  226.     ' GMT''!' printOn: aFileStream.    
  227.     Character nl printOn: aFileStream.
  228.     Character nl printOn: aFileStream.
  229.     categories asSortedCollection do:
  230.         [ :category | self emitCategory: category toStream: aFileStream ]
  231. !
  232.  
  233. fileOutCategory: categoryName
  234.     | aFileStream fileName |
  235.     name notNil
  236.         ifTrue: [ fileName _ name ]
  237.     ifFalse: [ fileName _ (self instanceClass name) , '-class' ].
  238.     fileName _ './categories/', fileName , '.st' .
  239.     aFileStream _ FileStream open: fileName mode: 'w'.
  240.     self emitCategory: categoryName toStream: aFileStream.
  241.     aFileStream close
  242. !!
  243.  
  244.  
  245.  
  246. !ClassDescription methodsFor: 'private'!
  247.  
  248. emitCategory: category toStream: aFileStream
  249.     "I write legal Smalltalk load syntax definitions of all of my methods
  250.      are in the 'category' category to the aFileStream"
  251.     '!' printOn: aFileStream.
  252.     self printOn: aFileStream.
  253.     ' methodsFor: ''' printOn: aFileStream.
  254.     category printOn: aFileStream.
  255.     '''!' printOn: aFileStream.
  256.     methodDictionary notNil
  257.       ifTrue: [ methodDictionary do:
  258.               [ :method | (method methodCategory) = category
  259.                       ifTrue: [ '
  260.  
  261. '                                printOn: aFileStream.
  262.                             method methodSourceString
  263.                                  printOn: aFileStream.
  264.                                 '!' printOn: aFileStream ] ] ].
  265.     '!
  266.  
  267. '   printOn: aFileStream
  268.  
  269. !
  270.  
  271. setName: aSymbol
  272.     name _ aSymbol
  273. !
  274.  
  275. setInstanceVariables: instVariableArray
  276.     instanceVariables _ instVariableArray
  277.  
  278. !!
  279.